home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
bbs
/
tdk_v136.zip
/
_EXIT.PAS
next >
Wrap
Pascal/Delphi Source File
|
1997-07-10
|
7KB
|
194 lines
{
▀▀▀▀▀▀▀▀ ▀▀▀▀▀▀ ▀▀ ▀▀
▀▀ ▀▀ ▀▀ ▀▀ ▀▀
▀▀ ▀▀ ▀▀▀ ▀▀▀▀▀ The DoorKit!
▀▀ ▀▀ ▀▀ ▀▀ ▀▀
▀▀ ▀▀▀▀▀▀ ▀▀ ▀▀
The BBS Door Development Kit By The People - For The People!
Feel free to modify or optimize this code at will. All I ask is that if
find a better way to do things (and you will), please send me a copy of
your modifications. Thanks in advance!....Larry L. Athey....}
UNIT _EXIT;
{ This unit will do the following:
--------------------------------
1. Installs a new exit procedure. If your program is halted by some sort of
internal error this will bypass the Pascal exit procedure and display a
better discription of the error as well as "Error Logging" the error.
2. Saves and restores the HEAP marker automatically. This means that you
don't have to use dispose or freemem before your program exits, because
this will free the entire heap that was used, so you don't have to do a
thing!
3. Installs a new memory handler. If you try to allocate a chunk of memory
to something and there's not enough heap, instead of halting with an
out of memory error like TP does, this will continue normally with the
program, but the variable that you tried to assign the memory to will
have the value NIL. This makes it easier to do error checks when
allocating memory. }
INTERFACE
USES DOS;
CONST
MAX_ExitProcs = 16; {Adjust as needed, up to 256 processes allowed.}
TYPE
TExitProc = PROCEDURE;
TProcAry = ARRAY[1..Max_ExitProcs] OF tExitProc; {Ary=1024 bytes}
FUNCTION AddtoExitChain(Proc : tExitProc) : BOOLEAN;
{^ This adds a procedure to the "Exit Chain". Any procedures in the Exit
Chain are called when your program ends, automatically...No matter how
the program gets terminated (Normally, Carrier Drop, HALT(), ^C).
Proc = Procedure to add. The procedure cannot have any parameters,
and MUST be compiled FAR.
The procedures are called in a "LIFO" (Last In First Out) fashion. This
is so the Comport routines will be the very last thing to DeInit itself.
For 2 reasons. 1] So you don't have to worry about Calling DeInitComport
at the end of your program. The DoorKit adds its own procedure to the
ExitChain to DeInit itself for you (it's always the very first procedure
in the chain) 2] Since The DoorKit itself is last to be shut down, any
of your procedures in the Exit Chain can use the comport still, if you
need / want to (so long as you don't call DeInitComport yourself!)....}
IMPLEMENTATION
TYPE
String10 = STRING[10];
CONST
ChainNum : INTEGER = 0;
VAR
ExitChain : TProcAry;
SavedExitProc : POINTER;
Hp : POINTER;
CONST
Hx : ARRAY[0..15] OF CHAR = '0123456789ABCDEF';
{───────────────────────────────────────────────────────────────────────────}
FUNCTION AddtoExitChain;
BEGIN
AddtoExitChain := FALSE;
IF (ChainNum < MAX_ExitProcs) AND (@Proc <> NIL) THEN BEGIN
INC(ChainNum);
ExitChain[ChainNum] := Proc;
AddtoExitChain := TRUE;
END;
END;
{───────────────────────────────────────────────────────────────────────────}
FUNCTION Hex2(B : BYTE) : String10;
BEGIN
Hex2 := Hx[(B SHR 4) AND 15] + Hx[B AND 15];
END;
{───────────────────────────────────────────────────────────────────────────}
FUNCTION Hex4(W : WORD) : String10;
BEGIN
Hex4 := Hex2(HI(W)) + Hex2(LO(W));
END;
{───────────────────────────────────────────────────────────────────────────}
FUNCTION CustomHeapError(Size : WORD) : INTEGER; Far;
BEGIN
CustomHeapError := 1;
END;
{───────────────────────────────────────────────────────────────────────────}
FUNCTION ErrorMessage(ECode : WORD) : STRING;
BEGIN
CASE ECode OF
1 : ErrorMessage := 'Invalid function number.';
2 : ErrorMessage := 'File not found.';
3 : ErrorMessage := 'Path not found.';
4 : ErrorMessage := 'Too many open files.';
5 : ErrorMessage := 'File access denied.';
6 : ErrorMessage := 'Invalid file handle.';
12 : ErrorMessage := 'Invalid file access code.';
15 : ErrorMessage := 'Invalid drive number.';
16 : ErrorMessage := 'Cannot remove current directory.';
17 : ErrorMessage := 'Cannot rename across drives.';
18 : ErrorMessage := 'No more files.';
100 : ErrorMessage := 'Disk read error.';
101 : ErrorMessage := 'Disk write error.';
102 : ErrorMessage := 'File not assigned.';
103 : ErrorMessage := 'File not open.';
104 : ErrorMessage := 'File not open for input.';
105 : ErrorMessage := 'File not open for output.';
106 : ErrorMessage := 'Invalid numeric format.';
150 : ErrorMessage := 'Disk is write-protected.';
151 : ErrorMessage := 'Bad drive request struct length.';
152 : ErrorMessage := 'Drive not ready.';
154 : ErrorMessage := 'CRC error in data.';
156 : ErrorMessage := 'Disk seek error.';
157 : ErrorMessage := 'Unknown media type.';
158 : ErrorMessage := 'Sector Not Found.';
159 : ErrorMessage := 'Printer out of paper.';
160 : ErrorMessage := 'Device write fault.';
161 : ErrorMessage := 'Device read fault.';
162 : ErrorMessage := 'Hardware failure.';
200 : ErrorMessage := 'Division by zero.';
201 : ErrorMessage := 'Range check error.';
202 : ErrorMessage := 'Stack overflow error.';
203 : ErrorMessage := 'Heap overflow error.';
204 : ErrorMessage := 'Invalid pointer operation.';
205 : ErrorMessage := 'Floating point overflow.';
206 : ErrorMessage := 'Floating point underflow.';
207 : ErrorMessage := 'Invalid floating point operation.';
208 : ErrorMessage := 'Overlay manager not installed.';
209 : ErrorMessage := 'Overlay file read error.';
210 : ErrorMessage := 'Object not initialized.';
211 : ErrorMessage := 'Call to abstract method.';
212 : ErrorMessage := 'Stream registration error.';
213 : ErrorMessage := 'Collection index out of range.';
214 : ErrorMessage := 'Collection overflow error.';
215 : ErrorMessage := 'Arithmetic overflow error.';
216 : ErrorMessage := 'General Protection fault.';
END;
END;
{───────────────────────────────────────────────────────────────────────────}
PROCEDURE CustomExit; Far;
VAR
I : INTEGER;
Txt : TEXT;
Msg : STRING;
DirInfo : SearchRec;
BEGIN
IF ErrorAddr <> NIL THEN BEGIN
Msg := ErrorMessage(ExitCode);
Asm mov ax,3; INT 10h END;
ASSIGN(Txt,'ERROR.LOG');
FINDFIRST('ERROR.LOG',Archive,DirInfo);
IF DOSERROR <> 0 THEN BEGIN
REWRITE(Txt);
CLOSE(Txt);
END;
APPEND(Txt);
WRITELN(Txt,'■ A RunTime Error Has Occured - Program Halted!');
WRITELN(Txt,' Address = ',Hex4(SEG(ErrorAddr^)),':',Hex4(OFS(ErrorAddr^)));
WRITELN(Txt,' ExitCode = ',ExitCode);
WRITELN(Txt,' Error = ',Msg);
WRITELN(Txt);
CLOSE(Txt);
RESET(Input);
ErrorAddr := NIL;
ExitCode := 0;
END;
FOR I := ChainNum DOWNTO 1 DO IF @ExitChain[I] <> NIL THEN ExitChain[I];
RELEASE(Hp);
ExitProc := SavedExitProc;
END;
{───────────────────────────────────────────────────────────────────────────}
BEGIN
SavedExitProc := ExitProc;
ExitProc := @CustomExit;
HeapError := @CustomHeapError;
MARK(Hp);
END.